home *** CD-ROM | disk | FTP | other *** search
/ Games of Daze / Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso / x2ftp / msdos / source / dptools / testfont.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-09-16  |  3.3 KB  |  128 lines
  1.  
  2. {programme repris pour char edit
  3.   realise par
  4.     charles vidal
  5.     pour toutes suggestions
  6.     email : vidal@amertume.ufr-info-p7.ibp.fr
  7. }
  8.  
  9. {─ Fido Pascal Conference ────────────────────────────────────────────── PASCAL ─
  10. Msg  : 580 of 708
  11. From : David Drzyzga                       1:3612/220.0         25 Apr 93  07:28
  12. To   : Dustin Nulf                         1:124/6304.0
  13. Subj : User defined Character S
  14. ────────────────────────────────────────────────────────────────────────────────
  15.  DN> Is there any way to create or use your own fonts in
  16.  DN> regular text mode with Pascal?
  17.  
  18. Yep. Here's a demo of a routine originally posted by Bernie P and revised by me:}
  19.  
  20. program testfont;
  21. {-upsidedown and backwards text aka redefining the text mode font}
  22. uses crt;
  23. type charset = array[0..255,1..16] of byte;
  24. var  newcharset, oldcharset : charset;
  25.      fichier:file of charset;
  26. procedure getoldcharset;
  27. var
  28.   b:byte;
  29.   w:word;
  30. begin
  31.   for b := 0 to 255 do begin
  32.     w := b * 32;
  33.     inline($FA);
  34.     PortW[$3C4] := $0402;
  35.     PortW[$3C4] := $0704;
  36.     PortW[$3CE] := $0204;
  37.     PortW[$3CE] := $0005;
  38.     PortW[$3CE] := $0006;
  39.     Move(Ptr($A000, w)^, oldcharset[b,1], 16);
  40.     PortW[$3C4] := $0302;
  41.     PortW[$3C4] := $0304;
  42.     PortW[$3CE] := $0004;
  43.     PortW[$3CE] := $1005;
  44.     PortW[$3CE] := $0E06;
  45.     inline($FB);
  46.   end;
  47. end;
  48.  
  49. procedure restoreoldcharset;
  50. var
  51.   b:byte;
  52.   w:word;
  53. begin
  54.   for b := 0 to 255 do begin
  55.     w := b * 32;
  56.     inline($FA);
  57.     PortW[$3C4] := $0402;
  58.     PortW[$3C4] := $0704;
  59.     PortW[$3CE] := $0204;
  60.     PortW[$3CE] := $0005;
  61.     PortW[$3CE] := $0006;
  62.     Move(oldcharset[b,1], Ptr($A000, w)^, 16);
  63.     PortW[$3C4] := $0302;
  64.     PortW[$3C4] := $0304;
  65.     PortW[$3CE] := $0004;
  66.     PortW[$3CE] := $1005;
  67.     PortW[$3CE] := $0E06;
  68.     inline($FB);
  69.   end;
  70. end;
  71.  
  72. procedure setasciichar(charnum : byte; var data);
  73. var
  74.    offset : Word;
  75. begin
  76.   offset := charNum * 32;
  77.   inline($FA);
  78.   PortW[$3C4] := $0402;
  79.   PortW[$3C4] := $0704;
  80.   PortW[$3CE] := $0204;
  81.   PortW[$3CE] := $0005;
  82.   PortW[$3CE] := $0006;
  83.   Move(data, Ptr($A000, offset)^, 16);
  84.   PortW[$3C4] := $0302;
  85.   PortW[$3C4] := $0304;
  86.   PortW[$3CE] := $0004;
  87.   PortW[$3CE] := $1005;
  88.   PortW[$3CE] := $0E06;
  89.   inline($FB);
  90. end;
  91. {-------------------------------------------}
  92. procedure aff_car;
  93. var i:byte;
  94. begin
  95.   ClrScr;
  96.   GotoXY( 1, 1 );
  97.   for i := 0 to 255 do         { Affiche le jeu complet des caractères }
  98.     begin
  99.       GotoXY( i mod 13 * 6 + 2, i div 13 + 1 );
  100.       write( i:3 , ':' );
  101.       if ( i <> 13 ) and ( i <> 10 ) and ( i <> 7 ) then
  102.        write( chr( i ) );
  103.     end;
  104.     GotoXY( 3, 22 );
  105.     writeln('Test Font '+paramstr(1)+' Charles vidal ' );
  106.     write('  Pour toutes suggestions vidal@amertume.ufr-info-p7.ibp.fr');
  107. end;
  108. {---------------------------------------------}
  109. var
  110.   b,c : byte;
  111.  
  112. begin
  113.   if paramcount=0 then
  114.                    begin
  115.                        writeln('entrez le nom de la font (.fnt)');
  116.                        halt(1);
  117.                    end;
  118.   getoldcharset;
  119.    assign(Fichier,paramstr(1));
  120.    reset(Fichier);
  121.    read(Fichier,newcharset);
  122.    close(fichier);
  123.   for b := 0 to 255 do setasciichar(b,newcharset[b,1]);
  124.   aff_car;
  125.   readln;
  126.   restoreoldcharset;
  127. end.
  128. {Have fun...}